(define-module (tapris util)
  #:use-module (ice-9 iconv)
  #:use-module (ice-9 match)
  #:use-module (ice-9 binary-ports)
  #:use-module (srfi srfi-1)
  #:use-module (web uri)
  #:use-module (rnrs bytevectors)
  #:export (file-encode
            alist->query
            uri-set-path-query))

;;;;;;;;;; FILE UTILS

(define (form-data-encode file-name file-type file-u8 boundary)
    (let* ((string->u8-list (lambda (str)
                              (bytevector->u8-list
                               (string->bytevector str "utf-8")))))
      (append (string->u8-list (string-append "--" boundary "\r\n"))
              (string->u8-list
               (string-append
                "Content-Disposition: form-data; name=\"file\";"
                "filename=\"" file-name "\"\r\n"
                "Content-Type: " file-type "\r\n\r\n"))
              file-u8
              (string->u8-list
               (string-append "\r\n--" boundary "--\r\n")))))

(define (file-encode filepath boundary)
  "Encode a file for multipart/form-data POST.  Returns a bytevector."
  (define mime-type
    '(("jpeg" . "image/jpeg")
      ("jpg"  . "image/jpeg")
      ("png"  . "image/png")
      ("gif"  . "image/gif")))

  (define file-name
    (car (last-pair (split-and-decode-uri-path filepath))))

  (define file-type
    (let* ((extention (car (last-pair (string-split file-name #\.))))
           (type (assoc-ref mime-type extention)))
      (if (string? type)
          type
          (throw 'mastodon '(("error" . "Unknown mime-type"))))))
  
  (let* ((file-port (open-file filepath "rb"))
         (file-u8   (bytevector->u8-list
                     (get-bytevector-all file-port)))
         (data      (form-data-encode file-name file-type file-u8 boundary)))
    (close file-port)
    (u8-list->bytevector data)))

;;;;;;;;;; URI UTILS

(define (my-uri-encode z)
  (cond
   ((string? z) (uri-encode z))
   ((number? z) (uri-encode (number->string z)))))

(define (alist->query lst)
  "Convert an association list into a query string."
  (define (f x acc)
    (match x
      ((arg . val)
       (string-append (my-uri-encode arg) "=" (my-uri-encode val)
                      "&" acc))
      (_ (error "assoc->query: input is not a pair " x))))
  (fold f "" lst))

(define (uri-set-path-query base path query)
  (build-uri (uri-scheme base)
               #:userinfo (uri-userinfo base)
               #:host (uri-host base)
               #:port (uri-port base)
               #:validate? #t
               #:path path
               #:query query))

